print(results)
# Final MLE
cat(sprintf("\nFinal MLE of theta after %d iterations: %.9f\n", iteration, theta_new))
library(dplyr)
y1 = 38; y2 = 34; y_sum = 125
compute_theta_hat = function() {
a = 197;b = -15;c = -68
discriminant = b^2 - 4*a*c
if (discriminant < 0) {
stop("No real solutions for theta.")
}
theta_hat = (-b + sqrt(discriminant)) / (2*a)
return(theta_hat)
}
theta_hat = compute_theta_hat()
cat(sprintf("Closed-form MLE of theta (theta_hat): %.9f\n\n", theta_hat))
theta_current = 0.1       ;tolerance = 1e-8         ;
max_iter = 100            ;iteration = 0          ;
results = data.frame(
Iteration = integer(),
Theta_t = numeric(),
Theta_hat = numeric(),
Residual = numeric(),
stringsAsFactors = FALSE
)
repeat {
iteration = iteration + 1
# E
y3_t = y_sum * (theta_current / 4) / (1/2 + theta_current / 4)
# M
theta_new = (y2 + y3_t) / (y1 + y2 + y3_t)
residual = if (iteration == 1) {
NA
} else {
(theta_new - theta_hat) / (theta_current - theta_hat)
}
# Store the results
results = rbind(results, data.frame(
Iteration = iteration - 1,
Theta_t = theta_current,
Theta_hat = theta_hat,
Residual = residual
))
if (abs(theta_new - theta_current) < tolerance || iteration >= max_iter) {
results = rbind(results, data.frame(
Iteration = iteration,
Theta_t = theta_new,
Theta_hat = theta_hat,
Residual = NA
))
break
}
# Update theta
theta_current = theta_new
}
results = results %>%
mutate(diff = abs(Theta_t - Theta_hat)) %>%
select(Iteration, Theta_t, diff)
ratio = numeric(dim(results)[1])
for (i in 1:dim(results)[1]){
ratio[i] = results[i+1,3]/results[i,3]
}
results = cbind(results,ratio)
results = round(results,9)
# Display the iteration
print(results)
# Final MLE
cat(sprintf("\nFinal MLE of theta after %d iterations: %.9f\n", iteration, theta_new))
library(dplyr)
y1 = 38; y2 = 34; y_sum = 125
compute_theta_hat = function() {
a = 197;b = -15;c = -68
discriminant = b^2 - 4*a*c
if (discriminant < 0) {
stop("No real solutions for theta.")
}
theta_hat = (-b + sqrt(discriminant)) / (2*a)
return(theta_hat)
}
theta_hat = compute_theta_hat()
cat(sprintf("Closed-form MLE of theta (theta_hat): %.9f\n\n", theta_hat))
theta_current = 0.1       ;tolerance = 1e-8         ;
max_iter = 100            ;iteration = 0          ;
results = data.frame(
Iteration = integer(),
Theta_t = numeric(),
Theta_hat = numeric(),
Residual = numeric(),
stringsAsFactors = FALSE
)
repeat {
iteration = iteration + 1
# E
y3_t = y_sum * (theta_current / 4) / (1/2 + theta_current / 4)
# M
theta_new = (y2 + y3_t) / (y1 + y2 + y3_t)
# Store the results
results = rbind(results, data.frame(
Iteration = iteration - 1,
Theta_t = theta_current,
Theta_hat = theta_hat,
Residual = residual
))
if (abs(theta_new - theta_current) < tolerance || iteration >= max_iter) {
results = rbind(results, data.frame(
Iteration = iteration,
Theta_t = theta_new,
Theta_hat = theta_hat,
Residual = NA
))
break
}
# Update theta
theta_current = theta_new
}
results = results %>%
mutate(diff = abs(Theta_t - Theta_hat)) %>%
select(Iteration, Theta_t, diff)
ratio = numeric(dim(results)[1])
for (i in 1:dim(results)[1]){
ratio[i] = results[i+1,3]/results[i,3]
}
results = cbind(results,ratio)
results = round(results,9)
# Display the iteration
print(results)
# Final MLE
cat(sprintf("\nFinal MLE of theta after %d iterations: %.9f\n", iteration, theta_new))
library(dplyr)
y1 = 38; y2 = 34; y_sum = 125
compute_theta_hat = function() {
a = 197;b = -15;c = -68
discriminant = b^2 - 4*a*c
if (discriminant < 0) {
stop("No real solutions for theta.")
}
theta_hat = (-b + sqrt(discriminant)) / (2*a)
return(theta_hat)
}
theta_hat = compute_theta_hat()
cat(sprintf("Closed-form MLE of theta (theta_hat): %.9f\n\n", theta_hat))
theta_current = 0.1       ;tolerance = 1e-10         ;
max_iter = 100            ;iteration = 0          ;
results = data.frame(
Iteration = integer(),
Theta_t = numeric(),
Theta_hat = numeric(),
Residual = numeric(),
stringsAsFactors = FALSE
)
repeat {
iteration = iteration + 1
# E
y3_t = y_sum * (theta_current / 4) / (1/2 + theta_current / 4)
# M
theta_new = (y2 + y3_t) / (y1 + y2 + y3_t)
# Store the results
results = rbind(results, data.frame(
Iteration = iteration - 1,
Theta_t = theta_current,
Theta_hat = theta_hat,
Residual = residual
))
if (abs(theta_new - theta_current) < tolerance || iteration >= max_iter) {
results = rbind(results, data.frame(
Iteration = iteration,
Theta_t = theta_new,
Theta_hat = theta_hat,
Residual = NA
))
break
}
# Update theta
theta_current = theta_new
}
results = results %>%
mutate(diff = abs(Theta_t - Theta_hat)) %>%
select(Iteration, Theta_t, diff)
ratio = numeric(dim(results)[1])
for (i in 1:dim(results)[1]){
ratio[i] = results[i+1,3]/results[i,3]
}
results = cbind(results,ratio)
results = round(results,9)
# Display the iteration
print(results)
# Final MLE
cat(sprintf("\nFinal MLE of theta after %d iterations: %.9f\n", iteration, theta_new))
use_rmarkdown_template()
library(usethis)
install.package("usethis")
install.packages("usethis")
library(usethis)
?usethis
use_rmarkdown_template()
library(usethis)
use_rmarkdown_template()
path.expand("~/Documents")
installed.packages()
library(Matrix)
library(MASS)
library(matrixStats)
library(osqp)
# library(kbal) # optional
library(RSpectra)
library(RcppParallel)
library(Rcpp)
library(RcppArmadillo)
setwd("C:/Users/uus03/OneDrive/Desktop/인추+최적화/solution/kernelfunc")
sourceCpp('RBF_kernel_C_parallel.cpp')
source("utils.R")
n=50
sig.123 <- diag(c(2,1,1))
sig.123[1,2] <- 1; sig.123[1,3] <- -1; sig.123[2,3] <- -0.5;
sig.123 <- forceSymmetric(sig.123)
beta_coef <- c(1,2,-2,-1,-0.5,1)
X.123 <- as.matrix(mvrnorm(n, mu = rep(0,3), Sigma = sig.123))
X.4 <- runif(n,-3,3)
X.5 <- rchisq(n,1)
X.6 <- rbinom(n,1,0.5)
X <- cbind(X.123, X.4, X.5, X.6)
A <- ifelse(X %*% matrix(beta_coef, ncol = 1) + rnorm(n,0,30) > 0,1,0)
Y <- (X.123[,1] + X.123[,2] + X.5)^2 + rnorm(n,0,1)
X
ptm <- proc.time()
# osqp kernel SBW with Nystrom approximation:
res <- osqp_kernel_sbw(X,A,Y,
delta.v=1e-4,
c = 100)
n=500
sig.123 <- diag(c(2,1,1))
sig.123[1,2] <- 1; sig.123[1,3] <- -1; sig.123[2,3] <- -0.5;
sig.123 <- forceSymmetric(sig.123)
beta_coef <- c(1,2,-2,-1,-0.5,1)
X.123 <- as.matrix(mvrnorm(n, mu = rep(0,3), Sigma = sig.123))
X.4 <- runif(n,-3,3)
X.5 <- rchisq(n,1)
X.6 <- rbinom(n,1,0.5)
X <- cbind(X.123, X.4, X.5, X.6)
A <- ifelse(X %*% matrix(beta_coef, ncol = 1) + rnorm(n,0,30) > 0,1,0)
Y <- (X.123[,1] + X.123[,2] + X.5)^2 + rnorm(n,0,1)
ptm <- proc.time()
# osqp kernel SBW with Nystrom approximation:
res <- osqp_kernel_sbw(X,A,Y,
delta.v=1e-4,
c = 100)
# with rank-restricted Nystrom approximation:
# res <- osqp_kernel_sbw(X,A,Y,
#                        delta.v=1e-4,
#                        dim.reduction=TRUE,
#                        c = 100, l=75, s=50)
et <- proc.time() - ptm
res
str(res)
knitr::opts_chunk$set(echo = TRUE)
library(tidyr)
library(dplyr)
library(ggplot2)
library(MASS)
library(ggh4x)
library(RcppParallel)
library(tidyr)
library(dplyr)
library(ggplot2)
library(MASS)
library(ggh4x)
library(RcppParallel)
library(tidyr)
library(dplyr)
library(ggplot2)
library(MASS)
library(ggh4x)
library(RcppParallel)
n = 500
set.seed(123)
# Treatment variable : F
F = rbinom(n, 1, 0.5)
# X1, X2, X3 : Joint Normal RV
mu = cbind(4*(2*F-1),
6*(2*F-1),
0)
Sigma = matrix(c(2, 1  , -1,
1, 1  , -0.5,
-1,-0.5,   1), nrow = 3)
X1X2X3 = data.frame(t(apply(mu, 1, function(m) mvrnorm(1, mu = m, Sigma = Sigma))))
colnames(X1X2X3)= c("X1","X2","X3")
# X4, X5, X6
X4 = runif(n,-3,3); X5 = rchisq(n,1); X6 = rbinom(n,1,0.5)
# Gaussian random noises
eps = rnorm(n,0,1); delta = rnorm(n,0,10)
df = data.frame(F,X1X2X3,X4,X5,X6,eps,delta)
# Treatment variable A
df = df %>%
mutate(A = as.integer(F + F * X1 + 2 * X2 - 2 * X3 - X4 - 0.5 * X5 + X6 + delta > 0))
# Y
tri = function(x) pmax(1-abs(x),0)
df = df %>%
mutate(Y = (X1 + X2 + X5)^2 + A * tri((X1-2)/2) + (1-A) * tri((X1+2)/2) + eps)
# Select F,X,A,Y
df = df %>%
dplyr::select(F, starts_with("X"), A, Y)
# W = (X*, F)
W = df %>%
mutate(
X1X3 = X1*X3,
X2sq = X2^2) %>%
dplyr::select(X1X3, X2sq ,X4, X5, X6, F)
# Propensity score vector
propensity_logit = glm(A ~ ., data = cbind(W, A = df$A), family = binomial)
propensity_score = predict(propensity_logit, type = "response")
# propensity가 0.001~0.999가 나오게
propensity_score = pmax(pmin(propensity_score, 0.999), 0.001)
# 유니폼 커널. h가 윈도우사이즈임
kernel_unif = function(W, w, h = 0.5) {
W_matrix = as.matrix(W)
w_vector = as.numeric(w)
diff = abs(W_matrix - matrix(w_vector, nrow(W_matrix), ncol(W_matrix), byrow = TRUE))
condition = (diff <= h )
K = apply(condition, 1, all)
return(K)
}
# IPW
ipw_numerator = function(W, w, Y, A, pi_hat, h = 0.5) {
K = kernel_unif(W, w, h = h)
terms = (A * Y / pi_hat) - ((1 - A) * Y / (1 - pi_hat))
weighted_terms = terms * K
numerator = mean(weighted_terms)
return(numerator)
}
# IPW 분모 계산 함수
ipw_denominator = function(W, w, h = 0.5) {
K = kernel_unif(W, w, h = h)
denominator = mean(K)
return(denominator)
}
# IPW 추정 함수
ipw_estimate = function(W, Y, A, pi_hat, h = 0.5) {
n = nrow(W)
tau_ipw = numeric(n)
for (i in 1:n) {
w = as.numeric(W[i, ])
numerator = ipw_numerator(W, w, Y, A, pi_hat, h = h)
denominator = ipw_denominator(W, w, h = h)
if (denominator == 0) {
cat("Warning: Denominator is zero for i =", i, "\n")
print(list(
w = w,
numerator = numerator,
denominator = denominator
))
}
tau_ipw[i] = numerator / denominator
}
return(tau_ipw)
}
# IPW 계산 실행
tau_ipw = ipw_estimate(W, df$Y, df$A, propensity_score, h = 0.5)
finaldf = data.frame(W=W, A=df$A, pi.hat=propensity_score, tau.w=tau_ipw) %>%
mutate(group=ifelse(tau.w>0,"s1","s2"))
# plot 1
plot_data = finaldf %>%
filter(group %in% c("s1", "s2")) %>%
dplyr::select(W.F, group) %>%
mutate(W.F = as.factor(W.F))
ggplot(plot_data, aes(x = group, fill = W.F)) +
geom_bar(position = "fill") +
scale_y_continuous(labels = scales::percent) +
labs(
title = "Dist of F (Setting 1)",
x = "Group",
y = "Proportion (%)",
fill = "F"
) +
theme_minimal()
# plot 2
fig2df = data.frame(df, pi.hat=propensity_score) %>%
dplyr::select(X1,X2,X3,X4,X5,X6,pi.hat,A)
A1 = fig2df[fig2df$A == 1,c(1:7)]
A0 = fig2df[fig2df$A == 0,c(1:7)]
A1 = A1 %>%
mutate(across(X1:X6, ~ .x / pi.hat, .names = "weighted.{.col}"))
weighted.A1 = A1[,c(8:13)]
A0 = A0 %>%
mutate(across(X1:X6, ~ .x / pi.hat, .names = "weighted.{.col}"))
weighted.A0 = A0[,c(8:13)]
plot_data = bind_rows(
mutate(weighted.A1, group = "A=1"),
mutate(weighted.A0, group = "A=0")
)
plot_data_long = plot_data %>%
pivot_longer(cols = starts_with("weighted"), names_to = "variable", values_to = "value") %>%
mutate(variable = gsub("weighted\\.", "", variable))
plot_data_filtered = plot_data_long %>%
group_by(variable) %>%
filter(value > quantile(value, 0.01) & value < quantile(value, 0.99)) %>%
ungroup()
plot_data_filtered = plot_data_filtered %>%
mutate(variable = factor(variable, levels = c("X1", "X2", "X3", "X4", "X5", "X6")))
ggplot(plot_data_filtered, aes(x = value, fill = group, color = group)) +
geom_density(alpha = 0.3) +
facet_wrap(~ variable, scales = "free", ncol = 3) +
labs(
title = "Density of Weighted Covariate X1 to X6 (Truncated)",
fill = "Group",
color = "Group"
) +
theme_minimal() +
theme(legend.position = "bottom")
W
setwd("C:/Users/uus03/OneDrive/Desktop/인추+최적화/solution/kernelfunc")
sourceCpp("RBF_kernel_C_parallel.cpp")
Wmatrix = as.matrix(W)
# 기준 벡터로 모든 샘플을 사용
stv = 1:nrow(W_matrix)
setwd("C:/Users/uus03/OneDrive/Desktop/인추+최적화/solution/kernelfunc")
sourceCpp("RBF_kernel_C_parallel.cpp")
W.matrix = as.matrix(W)
# 기준 벡터로 모든 샘플을 사용
stv = 1:nrow(W_matrix)
setwd("C:/Users/uus03/OneDrive/Desktop/인추+최적화/solution/kernelfunc")
sourceCpp("RBF_kernel_C_parallel.cpp")
W.matrix = as.matrix(W)
# 기준 벡터로 모든 샘플을 사용
stv = 1:nrow(W.matrix)
c = length(stv)
# RBF 커널 Gram 행렬 생성
K = RBF_kernel_C_parallel(W.matrix, c, stv)
K
W.matrix
K
K[1:5,1:5]
library(tidyr)
library(dplyr)
library(ggplot2)
library(MASS)
library(ggh4x)
library(RcppParallel)
library(Rmosek)
finaldf
library(tidyr)
library(dplyr)
library(ggplot2)
library(MASS)
library(ggh4x)
library(RcppParallel)
library(Rmosek)
library(Matrix)
setwd("C:/Users/uus03/OneDrive/Desktop/인추+최적화/solution/kernelfunc")
# RBF 커널 계산을 위한 C++ 코드 로드
sourceCpp("RBF_kernel_C_parallel.cpp")
# 데이터 정의
n <- 500  # 관측치의 수
R <- 2    # 하위 그룹의 수
# 커널 행렬 정의
# W 행렬을 설정하고 RBF 커널 Gram 행렬 K 생성
W.matrix <- as.matrix(W)  # W를 행렬로 변환
stv <- 1:nrow(W.matrix)  # 모든 샘플을 기준 벡터로 사용
c <- length(stv)  # 기준 벡터의 길이 설정
K <- RBF_kernel_C_parallel(W.matrix, c, stv)  # RBF 커널 Gram 행렬 생성
# MOSEK를 사용한 최적화 문제 정의
prob <- list(sense = "min")  # 최적화 목표를 최소화로 설정 (MICP에 맞게 수정)
# 결정 변수 정의: w, u, S, z
w <- rep(0, n * R)  # 연속 변수 w 정의
S <- matrix(0, n, R)  # 이진 변수 S 정의
z <- rep(0, n)  # 이진 변수 z 정의
# 목적 함수 설정: c^T * x
c <- c(rep(0, R * n), rep(1, length(w)), 0)  # 목적 함수의 계수 설정
prob$c <- c
# 변수의 경계 정의 (하한과 상한)
prob$bx <- rbind(rep(0, length(c)), rep(Inf, length(c)))  # 모든 변수의 하한과 상한 설정
# 제약 조건 정의
# 1. tau_r 계산 및 균형 제약 조건 (6c)
for (i in 1:n) {
for (j in 1:n) {
balance_index <- cbind(rep(i, n), 1:n)  # Gram 행렬의 컬럼을 균형 조건에 추가
prob$A <- rbind(prob$A, sparseMatrix(i = balance_index[, 1], j = balance_index[, 2], x = K[i, ]))
}
prob$bc <- rbind(prob$bc, c(0, 0))  # 균형 제약 조건 설정
}
df
W = df %>%
mutate(
X1X3 = X1*X3,
X2sq = X2^2) %>%
dplyr::select(X1X3, X2sq ,X4, X5, X6, F, A, Y)
W
W.matrix <- as.matrix(W[1:6,1:6])  # W를 행렬로 변환
stv <- 1:nrow(W.matrix)  # 모든 샘플을 기준 벡터로 사용
c <- length(stv)  # 기준 벡터의 길이 설정
K <- RBF_kernel_C_parallel(W.matrix, c, stv)  # RBF 커널 Gram 행렬 생성
K
str(K)
sourceCpp("RBF_kernel_C_parallel.cpp")
setwd("C:/Users/uus03/OneDrive/Desktop/인추+최적화/solution/kernelfunc")
# RBF 커널 계산을 위한 C++ 코드 로드
sourceCpp("RBF_kernel_C_parallel.cpp")
W = df %>%
mutate(
X1X3 = X1*X3,
X2sq = X2^2) %>%
dplyr::select(X1X3, X2sq ,X4, X5, X6, F, A, Y)
# 커널 행렬 정의
# W 행렬을 설정하고 RBF 커널 Gram 행렬 K 생성
W.matrix <- as.matrix(W[,1:6])  # W를 행렬로 변환
stv <- 1:nrow(W.matrix)  # 모든 샘플을 기준 벡터로 사용
c <- length(stv)  # 기준 벡터의 길이 설정
K <- RBF_kernel_C_parallel(W.matrix, c, stv)  # RBF 커널 Gram 행렬 생성
str(K)
W.matrix
rep(diag(2),2)
diag(2)
do.call(cbind, replicate(R, diag(3), simplify = FALSE))
